;;; Copyright © 2020 Maxime Devos <maximedevos@telenet.be>
;;; This file is part of rehash.
;;;
;;; rehash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; rehash is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with rehash.  If not, see <http://www.gnu.org/licenses/>.

;; Synopsis: try to figure out a hash from file name
;; Summary:
;;
;;  (recognise-url? FILENAME)
;;    --> (sha256 BYTEVECTOR)
;;    --> (unknown-narinfo SERVER-PREFIX STORE-HASH)
;;    --> (unknown-substitute SERVER-PREFIX COMPRESSION STORE-HASH NAME)
;;    --> #f
;;
;;  as appropriate. The cases unknown-narinfo and unknown-substitute
;;  need external information to figure out the hash.
;;  Make sure no #\nul characters are in FILENAME!
;;  These are not supported by guile's regex procedures.
;;
;;  compression may be "none"
;;
;;  TODO other hashes (e.g. blake2s, sha3, ...)

;; (not yet compiled, some syntax errors are possible)
(define-library (remirror recognise-hash-uri)
  (export sha256/swh? sha256/tarballs.nixos.org? sha256/simple?
          narinfo-url? substitute-url?
          recognise-url?)
  (import (only (rnrs base)
		begin define let lambda
		quasiquote unquote or)
	  (only (srfi srfi-2)
		and-let*)
	  ;; XXX make-regexp and regexp-exec are not in (ice-9 regex)
	  (only (guile) make-regexp regexp-exec)
	  (only (ice-9 regex)
		match:substring)
          (only (remirror base16)
                base16-string->bytevector)
	  (only (remirror base32)
		nix-base32-string->bytevector))

  (begin
    ;; Guix sometimes tries to download tarballs from
    ;; Software Heritage
    (define sha256/swh?
      (let ((rx (make-regexp "(^|/)sha256:([0-9a-f]{64})/raw$")))
        (lambda (string)
          (and-let* ((match (regexp-exec rx string)))
            `(sha256 ,(base16-string->bytevector
                       (match:substring match 2)))))))

    ;; Idem. FIXME tarballs.nixos.org also supports
    ;; some other hashes. Also supported by guix publish.
    (define sha256/tarballs.nixos.org?
      ;; FIXME verify length
      (let ((rx (make-regexp "(^|/)sha256/([0-9a-z]+)$")))
        (lambda (string)
          (and-let* ((match (regexp-exec rx string)))
            `(sha256 ,(nix-base32-string->bytevector
                       (match:substring match 2)))))))

    (define (sha256/simple? string)
      (or (sha256/swh? string)
	  (sha256/tarballs.nixos.org? string)))

    ;; FIXME why did I think this should be
    ;; (^|/)([0-9a-z]+-[.a-zA-Z0-9-]+).narinfo?
    ;; Perhaps some of remirror's documentation is wrong.

    (define narinfo-url?
      (let ((rx (make-regexp "^(.*)\\b([0-9a-z]+).narinfo$")))
	(lambda (string)
	  (and-let* ((match (regexp-exec rx string)))
	    `(unknown-narinfo ,(match:substring match 1)
			      ,(match:substring match 2))))))

    (define substitute-url/compressed?
      (let ((rx (make-regexp
		 "^(.*)\\bnar/([a-z]+)/([0-9a-z]+)-([.a-zA-Z0-9-]+)$")))
	(lambda (string)
	  (and-let* ((match (regexp-exec rx string)))
	    `(unknown-substitute ,(match:substring match 1)
				 ,(match:substring match 2)
				 ,(match:substring match 3)
				 ,(match:substring match 4))))))

    (define substitute-url/uncompressed?
      (let ((rx (make-regexp
		 "^(.*)\\bnar/([0-9a-z]+)-([.a-zA-Z0-9-]+)$")))
	(lambda (string)
	  (and-let* ((match (regexp-exec rx string)))
	    `(unknown-substitute ,(match:substring match 1)
				 "none"
				 ,(match:substring match 2)
				 ,(match:substring match 3))))))

    (define (substitute-url? string)
      (or (substitute-url/compressed? string)
	  (substitute-url/uncompressed? string)))

    (define (recognise-url? string)
      (or (sha256/simple? string)
	  (narinfo-url? string)
	  (substitute-url? string)))))
